;;########################################################################
;; functin2.lsp
;; contains new functions for frequency analysis of arrays.
;; Copyright (c) 1991-99 by Forrest W. Young
;;########################################################################
    
(defun variable-type (list)
"arg: list
returns \"numeric\" is all elements are numbers, \"category\" otherwise"
   (if (which (mapcar #'not (mapcar #'numberp list))) "category" "numeric"))

(defun sign (value)
"Arg number
Return T if number is greaer than zero, nil if number is less than zero, and zero if number equals zero"
     (cond ((> value 0) t) ((= value 0) 0) (t nil)))

#|old
(defun number-from-string (string)
"Args: STRING
Converts a number represented as a string into a number."
  (eval (read (make-string-input-stream string) nil)))
|#

(defun number-from-string (string)
"Args: ARG
When ARG is a string, converts a number represented as a string into a number.  Returns number unless string does not represent a number, where it returns the string. Returns NIL if the ARG is the missing value symbol."
  (let* ((result (read (make-string-input-stream string) nil)))
    (cond 
      ((numberp result) result)
      ((missingp-fwy result)
       nil)
      ((and (symbolp result)
            (equal result *missing-value-symbol*))
       nil)
      (t result))))
    


;----------------------------
;array functions
;----------------------------

(defun permute-array-level (array i)
"Args: array i
Permutes way I (0<=i<=(1-n)) of n-way array A into order based on ascending sums of elements"
     (rank (combine (apply #'+ (array-list array (list i))))))


(defun permute-array-levels (array i j)
"Args: array i j
Permutes array way i (0<=i<=(1-n)) of n-way array A into order based on ascending eigenvector values"
     (let* ((matrix (apply #'+ (array-list array (list i j))))
            (prod (%* matrix (transpose matrix)))
            (ev (eigenvectors prod))
            )
       (rank (combine (first ev)))))

(defun array-dimensionality (array)
  (length (array-dimensions array)))

(defun freq-matrix-to-freq-class (matrix two-levels)
  (let* ((sizes (array-dimensions matrix))
         (outmat (make-array (list (* (first sizes) (second sizes)) 3)))
         (k 0)
         )
    (dotimes (i (first sizes))
             (dotimes (j (second sizes))
                      
                      (setf (select outmat k 0) (select matrix i j))
                      (setf (select outmat k 1) (select (select two-levels 0) i))
                      (setf (select outmat k 2) (select (select two-levels 1) j))
                      (setf k (1+ k))))
    outmat))

(defun make-array-cv (cat-data)
"Args: cat-vars
CAT-VARS is either a list of category lists, a list of category vectors, or a matrix whose columns are category variables. Uses the N categories to form an N-way frequency array. Each way has levels equal to the categories of each corresponding variable. Returns a two-element list: 1) the frequency array and 2) a list of lists of array-level-labels (categories)." 
  (let* ((cat-data-mat 
          (if (listp cat-data) 
              (apply #'bind-columns cat-data)
              cat-data))
         (ncatvars (second (array-dimensions cat-data-mat)))
         (nobs (first (array-dimensions cat-data-mat)))
         (ncats (repeat nil ncatvars))
         (cats (mapcar 
                #'(lambda (i)
                    (coerce (remove-duplicates (col cat-data-mat i) :test #'equal) 
                            'list))
                (iseq ncatvars)))
         (freq-array)
         )
    (dotimes (i ncatvars)
             (setf (select ncats i) 
                   (length (remove-duplicates (col cat-data-mat i) :test #'equal))))
    (setf freq-array (make-array ncats :initial-element 0))
    (dotimes (i nobs)
             (setf element
                   (mapcar 
                    #'(lambda (j)
                        (position (aref cat-data-mat i j) (select cats j) :test #'equal))
                    (iseq ncatvars)))
             (setf (apply #'aref freq-array element) 
                   (1+ (apply #'aref freq-array element))))
    (list freq-array cats)))

(defun array-list (array indices &optional return-indices?)
  "Args: ARRAY INDICES &OPTIONAL RETURN-INDICES? 
ARRAY is an n-way array. INDICES is a M element list. RETURN-INDICES? is T or NIL.
  Returns a list or a list of two lists. The (first) list is a list of arrays selected from ARRAY according to the list INDICES. The returned arrays are M-way arrays, where M is the number of elements in INDICES. The ways of each returned array are the same as the ways in ARRAY indexed by INDICES (0-based). INDICES must be a list of 2 to N unique values, each in the range 0 to N-1, where N is the number of ways of ARRAY.
  If RETURN-INDICES? is T, then a second list is also returned. This list is a list of indices indicated the location of each array in the list of arrays.
  For example, if ARRAY is 4-way, and INDICES is the list (1 3), then each array in the returned list of arrays will be a matrix with rows corresponding to the second (index 1) way of ARRAY and columns to the fourth (index 3) way of ARRAY. The list will have elements consisting of matrices formed from all combinations of the levels of the remainings ways (the first and third) of ARRAY."
  (let ((result (make-array-list array indices))
        )
    (if return-indices?
        result
        (first result))))

(defun make-array-list (array indices &optional 
                         mlist ilist min-nways array-indices)
"used by array-list. don't use this one directly, use array-list instead
optional arguments are for internal recursive algorithm use only"
  (when (not min-nways)
        (when (or (> (length indices) (length (array-dimensions array)))
                  (which (< indices 0))
                  (which (> indices (1- (length (array-dimensions array))))))
              (error "bad array indices"))
        (setf array-indices (repeat 0 (length (array-dimensions array))))
        (mapcar #'(lambda (index)
                (setf (select array-indices index) !))
            indices)
        (setf min-nways (length indices)))
       ;(print (list "MAKE-ARRAY-LIST: INDICES" indices))
  (let* ((sizes (array-dimensions array))
         (nways (length sizes))
         (reducing-indices (set-difference (iseq nways) indices));???
         
         (reduction-index (first reducing-indices));(max reducing-indices)
         (returned-array) (returned-array-indices)
         (reduced-array)(subscripts))
;(TERPRI)
;(PRINT "FUNCTION MAKE-ARRAY-LIST")
;(PRINT (LIST (ISEQ NWAYS) INDICES))
;(PRINT (SET-DIFFERENCE (ISEQ NWAYS) INDICES))
    (cond
      ((= nways min-nways)
       ;(PRINT "MAKE-ARRAY-LIST (NWAYS=MIN): ARRAY")
       ;(print  array)
       ;(print (list "MAKE-ARRAY-LIST: ARRAY-INDICES" array-indices))
       (list (list array) (list (copy-list array-indices))))
      ((> nways min-nways)
       ;(PRINT "MAKE-ARRAY-LIST (NWAYS>MIN): ARRAY")
       ;(print array)
       ;(print (list "MAKE-ARRAY-LIST: ARRAY-INDICES" array-indices))
       (dotimes (i (select sizes reduction-index))
                (setf subscripts (repeat ! nways))
                (setf (select subscripts reduction-index) i)
                (setf (select array-indices reduction-index) i)
                (setf reduced-array (extract-array array subscripts))
                (setf new-indices 
                      (mapcar #'(lambda (index)
                                  (if (> index reduction-index) (1- index) index))
                              indices))
                (setf result (make-array-list reduced-array new-indices mlist ilist 
                                         min-nways array-indices))
                 ; (print result)
                (setf returned-array (first result))
                (setf returned-array-indices (second result))
                (cond
                  ((= 1 (length returned-array)) 
                   (setf mlist (append mlist returned-array))
                   (setf ilist (append ilist returned-array-indices))
                   )
                  (t
                   (setf mlist returned-array)
                   (setf ilist returned-array-indices)
                   )))
       (list mlist ilist))
      (t (error "Array-list: Impossible condition."))
      )))

;(defun set-difference (lista listb &key (testfunc #'eql)) 
;"Redefines set-difference so that it returns elements in order stated in first list"
;     (let ((newlist))
;       (mapcar #'(lambda (elementa)
;                   (setf newlist 
;                         (append newlist 
;                                 (list (if (member elementa listb :test testfunc) 
;                                           nil elementa)))))
;               lista)
;       (remove 'nil newlist)))
       
(defun extract-array (array &rest args)
"Args: ARRAY INDICES
Extracts a sub-array from ARRAY, where INDICES specifies the sub-array. The number of INIDICES must equal the number of ways of the array. Each index may be either an integer, a list of integers, or an !, where ! is a wildcard value meaning all levels of the index. Specifying an integer index reduces the number of levels of the returned array by one for each integer index. A list or integers or ! are not reducing operations. The indices for a way must in the range of number of levels of the way." 
    (let* ((nlevels (array-dimensions array))
           (nways (length nlevels))
           (nargs (length (first args)))
           (selection (repeat nil nargs))
           (nintegers)
           )
      (if (not (= nargs nways)) (error "Wrong number of indices"))
      (dotimes (i nargs)
               (setf argi (select (first args) i))
               (if (integerp argi)
                   (setf nintegers (1+ nintegers))
                   (when (not (equal argi "!"))
                         (when (not (listp argi))
                               (when (not (integer-listp argi))
      (error "Index arguments must be an integer, a list of integers, or a !")))))
               (if (equal argi "!")
                   (setf (select selection i) (iseq (select nlevels i)))
                   (setf (select selection i) argi)))
      (setf selection-sizes (remove nil (mapcar #'(lambda (i)
                  (if (integerp i) nil (length i))) selection)))
      (make-array selection-sizes :initial-contents 
                  (combine (apply #'select array selection)))
      ))


(defun map-array (fun array matrix-indices
                      &key map-at-levels 
                      verbose array-way-labels array-level-labels)
; I don't think I use this, nor that it works yet... fwy
"Args: (fun array &key map-at-levels verbose array-way-labels array-level-labels)
Maps function FUN over all of the submatrices of ARRAY whose rows and column are specified by MATRIX-INDICES, and at the intemediate levels specified by MAP-AT-LEVELS. VERBOSE causes labeling of results, using ARRAY-WAY-LABELS and ARRAY-LEVEL-LABELS."
  (let* ((sizes (array-dimensions array))
         (nways (length sizes))
         (subscripts)
         (reduced-array-level-labels (copy-list array-level-labels))
         (rest-array-level-labels)
         (rest-array-way-labels)
         )
    (cond
      ((> nways 2)
       (dotimes (i (first (last sizes)))
                (setf subscripts (repeat ! nways))
                (setf reduction-index 
                      (max (remove (first matrix-indices)
                                   (remove (second matrix-indices)
                                           (iseq nways)))))
                (setf (select subscripts reduction-index) i)
;(terpri)
;(print (list "subscripts" subscripts))
                (setf reduced-array 
                      (apply #'extract-array array subscripts))
                (when reduced-array-level-labels
                      (setf (select reduced-array-level-labels (1- nways))
                            (list (select (select array-level-labels (1- nways)) i)))) ;?
                (when (member nways map-at-levels)
                      (when verbose 
                            (label-array 
                             reduced-array-level-labels 
                             array-way-labels w))
                      (funcall fun array 
                               :array-way-labels array-way-labels
                               :array-level-lables reduced-array-level-lables))
                (map-array fun reduced-array (1- matrix-indices)
                      :array-way-labels array-way-labels
                      :array-level-lables reduced-array-level-labels)))
      ((= nways 2)
       (when (> (length array-way-labels) 2)
             (setf rest-array-level-labels (rest (rest array-level-labels)))
             (setf rest-array-way-labels (rest (rest array-way-labels)))
             (when verbose 
                   (label-array 
                    rest-array-level-labels 
                    rest-array-way-labels w)))
       (funcall fun array :level-labels rest-array-level-labels)))))

(defun label-array (level-labels way-labels w)
  (display-string (format nil "~2%For Matrix:") w)
  (dotimes (i (length level-labels))
           (display-string 
            (format nil "~%~a (level: ~a) "
                    (select way-labels i)
                    (first (select level-labels i))) w))
  (display-string (format nil "~%") w))

(defun chi-sq-contributions (arg1 &optional arg2)
"Args: Either FREQ-ARRAY or CELLS LEVELS
Calculates and returns the chi-square contribution for each cell of a frequency array under the hypothesis of additivity. Arguments are either FREQ-ARRAY or the CELLS and LEVELS 
information from which the frequency array is generated."
  (let* ((freq-array (if (arrayp arg1) arg1
                         (make-array arg2 :initial-contents arg1)))
         (expected-freq-array (first (expected-values freq-array))))
    (/ (- freq-array expected-freq-array) (sqrt expected-freq-array))));Pv


(defun expected-values (freq-array)
"Args: freq-array
Calculates expected frequencies for cells of an n-way frequency array. Returns a list with two elements. The first element is the n-way array of expected frequencies. The second is a list of lists of marginal proportions, one list for each way of the array."
  (let* ((sizes (array-dimensions freq-array))
         (expected (make-array sizes :initial-element 0))
         (nways (length sizes))
         (indices (repeat "!" nways))
         (marginal-props)
         (grand-sum (sum freq-array)))
    (dotimes (j nways)
             (setf marginal-props (add-element-to-list marginal-props
                   (/ (mapcar #'sum 
                           (mapcar #'(lambda (i) 
                                       (setf (select indices j) i)
                                       (extract-array freq-array indices))
                                   (iseq (select sizes j))))
                      grand-sum)))
             (setf (select indices j) !))
    (dotimes (i (first sizes))
             (nested-prod (list i) 
                          (select (first marginal-props) i) 
                          (rest marginal-props) 
                          (rest sizes) expected))
    (if (= nways 1)
        (setf expected (repeat (/ grand-sum (first sizes)) (first sizes)))
        (setf expected (* expected grand-sum)))
    (list expected marginal-props)))
